home *** CD-ROM | disk | FTP | other *** search
/ Gold Medal Software 3 / Gold Medal Software - Volume 3 (Gold Medal) (1994).iso / prog / pbc23c.arj / SHOWBMP.BAS < prev    next >
BASIC Source File  |  1994-03-13  |  4KB  |  100 lines
  1. '   +----------------------------------------------------------------------+
  2. '   |                                                                      |
  3. '   |        PBClone  Copyright (c) 1990-1994  Thomas G. Hanlin III        |
  4. '   |                                                                      |
  5. '   +----------------------------------------------------------------------+
  6.  
  7.    DECLARE FUNCTION AscM% (St$, BYVAL Posn%)
  8.    DECLARE SUB DFRead (BYVAL FileHandle%, BYVAL DSeg%, BYVAL DOfs%, BYVAL Bytes%, BytesRead%, ErrCode%)
  9.    DECLARE SUB FClose1 (BYVAL FileHandle%)
  10.    DECLARE SUB FOpen1 (FileName$, BYVAL ReadWrite%, BYVAL Sharing%, FileHandle%, ErrCode%)
  11.    DECLARE SUB FSetLoc (BYVAL FileHandle%, Posn&)
  12.    DECLARE FUNCTION FSize2& (BYVAL FileHandle%)
  13.    DECLARE SUB SFRead (BYVAL FileHandle%, St$, BytesRead%, ErrCode%)
  14.  
  15.    DECLARE SUB PalBlock0 (BYVAL DSeg%, BYVAL DOfs%, BYVAL Colors%)
  16.  
  17. SUB ShowBMP (File$, OrigX%, OrigY%, ErrCode%)
  18.    ErrCode% = 0
  19.    FOpen1 File$, 0, 2, Handle%, ErrCode%    ' open for read, deny write
  20.    IF ErrCode% = 0 THEN
  21.       Header$ = SPACE$(54)
  22.       SFRead Handle%, Header$, BytesRead%, ErrCode%
  23.       IF ErrCode% = 0 THEN
  24.          PWide& = CVL(MID$(Header$, 19, 4))
  25.          PHigh& = CVL(MID$(Header$, 23, 4))
  26.          BitPlanes% = CVI(MID$(Header$, 27, 2))
  27.          ColorBits% = CVI(MID$(Header$, 29, 2))
  28.          IF LEFT$(Header$, 2) <> "BM" THEN
  29.             ErrCode% = -1    ' invalid BMP
  30.          ELSEIF NOT (BitPlanes% = 1 AND ColorBits% = 8) THEN
  31.             ErrCode% = -2    ' color format not supported
  32.          ELSEIF CVL(MID$(Header$, 31, 4)) <> 0& THEN
  33.             ErrCode% = -3    ' compression not supported
  34.          ELSEIF CVL(MID$(Header$, 3, 4)) <> FSize2&(Handle%) THEN
  35.             ErrCode% = -4    ' incorrect file size
  36.          ELSEIF PWide& < 1& OR PHigh& < 1& THEN
  37.             ErrCode% = -5    ' ludicrous image size
  38.          ELSEIF PWide& > 320& OR PHigh& > 200& THEN
  39.             IF OrigX% >= 0 AND OrigY% >= 0 THEN
  40.                ErrCode% = -5    ' ludicrous image size
  41.             END IF
  42.          END IF
  43.          IF ErrCode% = 0 THEN
  44.             PicWidth% = PWide&
  45.             PicHeight% = PHigh&
  46.             IF OrigX% < 0 OR OrigY% < 0 THEN
  47.                OX% = 0
  48.                OY% = 0
  49.                IF PicWidth% > 320 OR PicHeight% > 200 THEN
  50.                   WideRatio! = PicWidth% / 320!
  51.                   HighRatio! = PicHeight% / 200!
  52.                   IF WideRatio! > HighRatio! THEN
  53.                      MaxX! = PicWidth% - 1
  54.                      MaxY! = 200! * WideRatio!
  55.                   ELSE
  56.                      MaxX! = 320! * HighRatio!
  57.                      MaxY! = PicHeight% - 1
  58.                   END IF
  59.                   WINDOW SCREEN (0, 0)-(MaxX!, MaxY!)
  60.                END IF
  61.             ELSEIF OrigX% + PicWidth% > 320 OR OrigY% + PicHeight% > 200 THEN
  62.                ErrCode% = -6      ' invalid (X,Y) origin specified
  63.             ELSE
  64.                OX% = OrigX%
  65.                OY% = OrigY%
  66.             END IF
  67.          END IF
  68.       END IF
  69.  
  70.       '----- set the palette -----
  71.       IF ErrCode% = 0 THEN
  72.          DIM Pal&(0 TO 255)
  73.          DSeg% = VARSEG(Pal&(0))
  74.          DOfs% = VARPTR(Pal&(0))
  75.          Bytes% = 1024            ' 256 * 4 is size of palette block
  76.          DFRead Handle%, DSeg%, DOfs%, Bytes%, BytesRead%, ErrCode%
  77.          IF ErrCode% = 0 THEN
  78.             PalBlock0 DSeg%, DOfs%, 256
  79.          END IF
  80.       END IF
  81.  
  82.       '----- draw the picture -----
  83.       IF ErrCode% = 0 THEN
  84.          FSetLoc Handle%, CVL(MID$(Header$, 11, 4)) + 1&
  85.          Bytes% = ((PicWidth% + 3) \ 4) * 4
  86.          st$ = SPACE$(Bytes%)
  87.          FOR y% = 0 TO PicHeight% - 1
  88.             SFRead Handle%, st$, BytesRead%, ErrCode%
  89.             IF ErrCode% THEN EXIT FOR
  90.             CurrY% = (PicHeight% - y%) + OY%
  91.             FOR x% = 0 TO PicWidth% - 1
  92.                PSET (x% + OX%, CurrY%), AscM(st$, x% + 1)
  93.             NEXT
  94.          NEXT
  95.       END IF
  96.  
  97.       FClose1 Handle%
  98.    END IF
  99. END SUB
  100.